home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / examples / scheme / unify < prev    next >
Encoding:
Text File  |  1991-12-02  |  1.3 KB  |  65 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; From Kent Dybvig's book on Chez Scheme
  4.  
  5. (define unify)
  6.  
  7. (letrec
  8.     ((occurs?
  9.       (lambda (u v)
  10.     (and (pair? v)
  11.          (define (f l)
  12.         (and (not (null? l))
  13.              (or (eq? u (car l))
  14.              (occurs? u (car l))
  15.              (f (cdr l)))))
  16.          (f (cdr v)))))
  17.      (sigma
  18.       (lambda (u v s)
  19.     (lambda (x)
  20.       (define (f x)
  21.         (if (symbol? x)
  22.         (if (eq? x u) v x)
  23.         (cons (car x) (map f (cdr x)))))
  24.       (f (s x)))))
  25.      (try-subst
  26.       (lambda (u v s ks kf)
  27.     (let ((u (s u)))
  28.       (if (not (symbol? u))
  29.           (uni u v s ks kf)
  30.           (let ((v (s v)))
  31.         (cond
  32.          ((eq? u v) (ks s))
  33.          ((occurs? u v) (kf "loop"))
  34.          (else (ks (sigma u v s)))))))))
  35.      (uni
  36.       (lambda (u v s ks kf)
  37.     (cond
  38.      ((symbol? u) (try-subst u v s ks kf))
  39.      ((symbol? v) (try-subst v u s ks kf))
  40.      ((and (eq? (car u) (car v))
  41.            (= (length u) (length v)))
  42.       (define (f u v s)
  43.         (if (null? u)
  44.         (ks s)
  45.         (uni (car u)
  46.              (car v)
  47.              s
  48.              (lambda (s) (f (cdr u) (cdr v) s))
  49.              kf)))
  50.       (f (cdr u) (cdr v) s))
  51.       (else (kf "clash"))))))
  52.      (set! unify
  53.        (lambda (u v)
  54.          (uni u
  55.           v
  56.           (lambda (x) x)
  57.           (lambda (s) (s u))
  58.           (lambda (msg) msg)))))
  59.         
  60. (print (unify 'x 'y))
  61. (print (unify '(f x y) '(g x y)))
  62. (print (unify '(f x (h)) '(f (h) y)))
  63. (print (unify '(f (g x) y) '(f y x)))
  64. (print (unify '(f (g x) y) '(f y (g x))))
  65.